home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
BBS in a Box 7
/
BBS in a Box - Macintosh - Volume VII (BBS in a Box) (January 1993).iso
/
Files
/
Tele
/
Pete Johnson
/
Flip 1.0.3<source>.cpt
/
Flip.p
next >
Wrap
Text File
|
1991-06-23
|
20KB
|
760 lines
program Flip;
{ Version 1.0.3 }
{ }
{ Program written by Pete Johnson for the Glassell Park BBS • (213) 254-4133. }
{ Reads script to send files out to Fido nodes. }
{ }
{ Release notes: }
{ V 1.0 released for about a day 12/1/90. }
{ V 1.01 (12/2/90) fixes occasional sending of script file. }
{ V 1.02 (5/30/91) adds SIZE resource. }
{ V 1.0.3 (6/23/91) removes CloseWD call. }
uses
FlipGlobals, HelloTabby, TxWrite, WriteMsg;
type
DayOfWeek = (Sunday, Monday, Tuesday, Wednesday, Thursday, Friday, Saturday, EveryDay);
const
MaxOldies = 40;
var
WhereAt, DataFileName, Location, When, RegisterSTR, OwnerName, Unreg: str255;
OldiesCount, FileCount, SendToCount: integer;
SendFiles: array[1..10] of string[32];
SendTo: array[1..10] of string[16];
FilesProcessed: array[1..MaxOldies] of string[32];
RunDialog: DialogPtr;
GoodName: boolean;
{ ------------------------------------------------------ }
function StringToDay (DayString: str255): DayOfWeek;
begin
uprString(DayString, false);
if pos('SUN', DayString) = 1 then
StringToDay := Sunday
else if pos('MON', DayString) = 1 then
StringToDay := Monday
else if pos('TUE', DayString) = 1 then
StringToDay := Tuesday
else if pos('WED', DayString) = 1 then
StringToDay := Wednesday
else if pos('THU', DayString) = 1 then
StringToDay := Thursday
else if pos('FRI', DayString) = 1 then
StringToDay := Friday
else if pos('SAT', DayString) = 1 then
StringToDay := Saturday
else
StringToDay := EveryDay
end;
{----------------------------------------------------------------- }
function DayToString (Day: DayOfWeek): str255;
begin
case Day of
Sunday:
DayToString := 'Sunday';
Monday:
DayToString := 'Monday';
Tuesday:
DayToString := 'Tuesday';
Wednesday:
DayToString := 'Wednesday';
Thursday:
DayToString := 'Thursday';
Friday:
DayToString := 'Friday';
Saturday:
DayToString := 'Saturday';
otherwise
DayToString := 'Every Day'
end
end;
{----------------------------------------------------------------- }
function WhatDay: DayOfWeek;
var
Today: DateTimeRec;
begin
GetTime(Today);
case Today.dayOfWeek of
1:
WhatDay := Sunday;
2:
WhatDay := Monday;
3:
WhatDay := Tuesday;
4:
WhatDay := Wednesday;
5:
WhatDay := Thursday;
6:
WhatDay := Friday;
otherwise
WhatDay := Saturday
end
end;
{----------------------------------------------------------------- }
procedure FrameDItem (dLog: DialogPtr; iNum: integer);
var
iBox: Rect;
iType: integer;
iHandle: Handle;
oldPenState: PenState;
begin
GetPenState(oldPenState);
GetDItem(dLog, iNum, iType, iHandle, iBox);
InsetRect(iBox, -4, -4);
PenSize(3, 3);
FrameRoundRect(iBox, 16, 16);
SetPenState(oldPenState)
end;
{----------------------------------------------------------------- }
procedure myCloseWD;
var
counter: integer;
myWDPBRec: WDPBRec;
begin
counter := 0;
repeat
counter := succ(counter);
with myWDPBRec do
begin
ioCompletion := nil;
ioWDProcID := mySignature;
ioWDIndex := counter;
ioVRefNum := 0;
end;
Err := PBGetWDInfo(@myWDPBRec, false);
if Err = noErr then
Err := PBCloseWD(@myWDPBRec, false);
until Err <> noErr
end;
{----------------------------------------------------------------- }
procedure MakePath (FName: STR255; VRefNum: integer; var MyPath: STR255);
var
MyPB: CInfoPBRec;
begin
MyPath := '';
MyPB.ioCompletion := nil;
MyPB.ioNamePtr := @FName;
MyPB.ioVRefNum := VRefNum;
MyPB.ioFDirIndex := 0;
MyPB.ioDirID := 0;
Err := PBGetCatInfo(@MyPB, false);
MyPB.ioFDirIndex := -1;
MyPB.ioDirID := MyPB.ioDRParID;
while PBGetCatInfo(@MyPB, false) = NoErr do
begin
MyPath := concat(MyPB.ioNamePtr^, ':', MyPath);
MyPB.ioDirID := MyPB.ioDRParID;
MyPB.ioFDirIndex := -1;
end; { while PBGetCatInfo(@MyPB, false) = NoErr }
end;
{ ------------------------------------------------------ }
procedure FitToASCII (var Check: integer);
begin
Check := Check mod 126;
if Check < 32 then
Check := Check + 32
end;
{ ------------------------------------------------------ }
procedure VerifyRegistration;
var
Check1, Check2, Check3, Check4, Check5, Counter: integer;
begin
Check1 := 0;
Check2 := 0;
GoodName := true;
OwnerName := copy(RegisterSTR, 1, length(RegisterSTR) - 5);
for Counter := 1 to length(OwnerName) do
begin
Check1 := Check1 + (ord(OwnerName[Counter]) mod 51);
Check2 := Check2 + Counter;
end;
Check3 := (length(OwnerName) * ord(OwnerName[length(OwnerName)]));
Check4 := ord(RegisterSTR[length(RegisterSTR) - 1]);
FitToASCII(Check1);
FitToASCII(Check2);
FitToASCII(Check3);
Check5 := Check1 + Check2 + Check3 + Check4;
FitToASCII(Check5);
if (ord(RegisterSTR[length(RegisterSTR) - 4]) <> Check1) then
GoodName := false
else if (ord(RegisterSTR[length(RegisterSTR) - 3]) <> Check2) then
GoodName := false
else if (ord(RegisterSTR[length(RegisterSTR) - 2]) <> Check3) then
GoodName := false
else if (ord(RegisterSTR[length(RegisterSTR)]) <> Check5) then
GoodName := false;
if not GoodName then
OwnerName := Unreg
end;
{----------------------------------------------------------------- }
procedure Configure;
var
theDialog: DialogPtr;
ItemHit, itemType, fRef: integer;
DelayTime: longint;
dispRect: Rect;
itemHandle: Handle;
where, leftLine, rightLine: point;
fileReply: SFReply;
whatToFind: SFTypeList;
TempString: str255;
{----------}
procedure FlashButton (WhichButton: integer);
begin
getDItem(theDialog, WhichButton, itemType, itemHandle, dispRect);
InsetRect(dispRect, 1, 1);
InvertRect(dispRect);
if StillDown then
repeat
until not Button
else
Delay(4, DelayTime);
Delay(4, DelayTime)
end;
{----------}
procedure DrawBox (ItemNo: integer; Info: str255);
begin
ForeColor(RedColor);
getDItem(theDialog, ItemNo, itemType, itemHandle, dispRect);
SetIText(itemHandle, Info);
ForeColor(BlueColor);
insetRect(dispRect, -1, -1);
FrameRect(dispRect)
end;
{----------}
procedure Refresh;
begin
ForeColor(BlueColor);
TextFont(Geneva);
TextSize(9);
PenPat(Gray);
getDItem(theDialog, 18, itemType, itemHandle, dispRect);
SetIText(itemHandle, concat('version ', VERSION, ' of ', compdate));
ForeColor(RedColor);
getDItem(theDialog, 14, itemType, itemHandle, dispRect); { user item for © info }
MoveTo(dispRect.left, dispRect.bottom - 2);
DrawString('©1990 by Pete Johnson. All rights reserved.');
DrawBox(3, NextLaunch);
DrawBox(4, DataFileName);
DrawBox(5, Location);
DrawBox(16, When);
DrawBox(17, OwnerName);
PenPat(Black);
ForeColor(BlackColor);
FrameDItem(theDialog, Ok)
end;
{----------}
begin
InitCursor;
Err := FSOpen(concat(gDefaultpath, 'Flip ID'), vRefNum, fRef);
if Err = NoErr then
begin
Err := ReadALine(fRef, RegisterSTR);
VerifyRegistration;
RmveResource(GetResource('STR ', 504));
UpdateResFile(CurResFile);
AddResource(Handle(NewString(RegisterSTR)), 'STR ', 504, 'Registration')
end;
Err := FSClose(fRef);
theDialog := GetNewDialog(500, nil, POINTER(-1));
SetPort(theDialog);
if StillDown then
repeat
until not Button;
DrawDialog(theDialog);
Refresh;
repeat
ModalDialog(nil, ItemHit);
case ItemHit of
1: { OK button hit -- save resources }
begin
getDItem(theDialog, 3, itemType, itemHandle, dispRect);
GetIText(itemHandle, NextLaunch);
RmveResource(GetResource('STR ', 500));
UpdateResFile(CurResFile);
AddResource(Handle(NewString(NextLaunch)), 'STR ', 500, 'Next Launch');
getDItem(theDialog, 4, itemType, itemHandle, dispRect);
GetIText(itemHandle, DataFileName);
RmveResource(GetResource('STR ', 501));
UpdateResFile(CurResFile);
AddResource(Handle(NewString(DataFileName)), 'STR ', 501, 'Data File');
getDItem(theDialog, 5, itemType, itemHandle, dispRect);
GetIText(itemHandle, Location);
RmveResource(GetResource('STR ', 502));
UpdateResFile(CurResFile);
AddResource(Handle(NewString(Location)), 'STR ', 502, 'Location');
getDItem(theDialog, 16, itemType, itemHandle, dispRect);
GetIText(itemHandle, When);
When := DayToString(StringToDay(When));
RmveResource(GetResource('STR ', 503));
UpdateResFile(CurResFile);
AddResource(Handle(NewString(When)), 'STR ', 503, 'When');
end;
6:
begin { Look Up Next Launch button }
FlashButton(6);
InvertRect(dispRect);
where.h := 60;
where.v := 80;
whatToFind[0] := 'APPL';
ParamText('default application to launch', '', '', '');
SFGetFile(where, '', nil, 1, whatToFind, nil, fileReply);
if fileReply.good then
NextLaunch := fileReply.fName;
Refresh
end;
7:
begin { Look Up Log Path button }
FlashButton(7);
InvertRect(dispRect);
where.h := 60;
where.v := 80;
SFPutFile(where, 'Please select file location ', 'test.$', nil, fileReply);
if fileReply.good then
begin
Err := Create(fileReply.fname, fileReply.vRefNum, 'QED1', 'TEXT');
MakePath(fileReply.fname, fileReply.vRefNum, Location);
Err := FSDelete(fileReply.fname, fileReply.vRefNum);
getDItem(theDialog, 5, itemType, itemHandle, dispRect);
SetIText(itemHandle, Location)
end;
Refresh
end;
8:
begin
FlashButton(8);
InvertRect(dispRect);
getDItem(theDialog, 16, itemType, itemHandle, dispRect);
When := DayToString(pred(StringToDay(When)));
Refresh
end;
9:
begin
FlashButton(9);
InvertRect(dispRect);
getDItem(theDialog, 16, itemType, itemHandle, dispRect);
if (StringToDay(When) = EveryDay) then
When := DayToString(Sunday)
else
When := DayToString(succ(StringToDay(When)));
Refresh
end;
16:
begin
FlashButton(16);
When := DayToString(EveryDay);
Refresh
end;
20:
begin { Look Up Info File button }
FlashButton(20);
InvertRect(dispRect);
where.h := 60;
where.v := 80;
whatToFind[0] := 'TEXT';
ParamText('info file to use', '', '', '');
SFGetFile(where, '', nil, 1, whatToFind, nil, fileReply);
if fileReply.good then
DataFileName := fileReply.fName;
Refresh
end;
otherwise
; { do nothing }
end { case statement }
until (ItemHit = 1) or (ItemHit = 2);
DisposDialog(theDialog)
end;
{ ------------------------------------------------------ }
procedure GetGenericPath;
{ returns path to Generic Folder ending in colon or else empty string }
var
GenericID: integer;
begin
Err := FSOpen(concat(gDefaultpath, 'Generic'), vRefNum, GenericID);
if Err = NoErr then
begin
Err := ReadALine(GenericID, GenericPath);
Err := FSClose(GenericID)
end
else
GenericPath := ''
end;
{ ------------------------------------------------------ }
procedure ForwardFile (TheFile: str255);
{ send file to recipients, add it to end of FilesProcessed array }
var
Counter, fRef: integer;
fName: str255;
begin
for Counter := 1 to SendToCount do
begin
fName := concat(GenericPath, 'sendfiles', SendTo[Counter], '.bbs');
MakeTextFile(fName);
Err := FSOpen(fName, vRefNum, fRef);
if Err = NoErr then
begin
Err := SetFPos(fRef, fsFromLEOF, 0);
if Err = NoErr then
Err := WrLn(fRef, concat(Location, TheFile));
SendMessage(SendTo[Counter], OwnerName, TheFile)
end;
Err := FSClose(fRef)
end; { for Counter := 1 to SendToCount }
if OldiesCount < MaxOldies then
begin
OldiesCount := succ(OldiesCount);
FilesProcessed[OldiesCount] := TheFile
end
else
begin
for Counter := 20 to 2 do
FilesProcessed[Counter] := FilesProcessed[Counter - 1];
FilesProcessed[1] := TheFile
end
end;
{ ------------------------------------------------------ }
procedure LookFor (MagicName: str255; myWDPB: WDPBRec);
var
CheckPB: CInfoPBRec;
Count, Index: integer;
Result, NewFile: boolean;
TempString: str255;
begin
uprString(MagicName, false);
Count := 1;
repeat
WhereAt := Location;
CheckPB.ioNamePtr := @WhereAt;
CheckPB.ioFDirIndex := Count;
CheckPB.ioCompletion := nil;
CheckPB.iovRefNum := MyWDPB.iovRefNum;
CheckPB.ioDrDirID := 0;
Err := PBGetCatInfo(@CheckPB, false);
if (Err = NoErr) & not (BitTst(@CheckPB.ioFlAttrib, 3)) then { make sure it's a file, not a folder }
begin
NewFile := false;
TempString := CheckPB.ioNamePtr^;
uprString(TempString, false);
if (pos(MagicName, TempString) = 1) | ((pos(MagicName, '*') = 1) & (length(MagicName) = 1)) then
begin
if not (EqualString(TempString, DataFileName, false, false)) then
begin
NewFile := true;
for Index := 1 to OldiesCount do
begin
if (EqualString(FilesProcessed[Index], TempString, false, false)) then
begin
NewFile := false;
leave
end { if (EqualString(FilesProcessed[Index], TempString, false, false)) }
end { for Index := 1 to OldiesCount }
end; { if not (EqualString(TempString, DataFileName, false, false)) }
if NewFile then
ForwardFile(CheckPB.ioNamePtr^)
end { contains MagicName or is * )}
end;
Count := succ(Count)
until (Err <> NoErr)
end;
{ ------------------------------------------------------ }
procedure Verify (var MagicName: str255; myWDPB: WDPBRec);
var
CheckPB: CInfoPBRec;
Count, Index: integer;
StillExists: boolean;
begin
uprString(MagicName, false);
Count := 1;
StillExists := false;
repeat
WhereAt := Location;
CheckPB.ioNamePtr := @WhereAt;
CheckPB.ioFDirIndex := Count;
CheckPB.ioCompletion := nil;
CheckPB.iovRefNum := MyWDPB.iovRefNum;
CheckPB.ioDrDirID := 0;
Err := PBGetCatInfo(@CheckPB, false);
if (Err = NoErr) then
if not (BitTst(@CheckPB.ioFlAttrib, 3)) then { make sure it's a file, not a folder }
if (EqualString(MagicName, CheckPB.ioNamePtr^, false, false)) then
StillExists := true;
Count := succ(Count)
until (Err <> NoErr) | (StillExists = true);
if (not StillExists) then
MagicName := ''
end;
{ ------------------------------------------------------ }
procedure ReadInfo;
const
FileMode = 1;
SendToMode = 2;
OldiesMode = 3;
var
Counter, InfoFile: integer;
TempString: str255;
Mode: integer;
begin
for Counter := 1 to 10 do
begin
SendFiles[Counter] := '';
SendTo[Counter] := '';
end;
for Counter := 1 to MaxOldies do
FilesProcessed[Counter] := '';
FileCount := 1;
SendToCount := 1;
OldiesCount := 1;
Mode := FileMode;
Err := FSOpen(concat(Location, DataFileName), vRefNum, InfoFile);
if Err = NoErr then
while (not AtEOF(InfoFile)) do
begin
Err := ReadALine(InfoFile, TempString);
if (TempString[1] <> ';') then { ignore remarks }
begin
if not ((TempString[1] = '•') & (length(TempString) = 1)) then
begin
case Mode of
FileMode:
if (FileCount < 11) then
begin
SendFiles[FileCount] := TempString;
FileCount := succ(FileCount)
end;
SendToMode:
if (SendToCount < 11) then
begin
SendTo[SendToCount] := TempString;
SendToCount := succ(SendToCount)
end;
OldiesMode:
if (OldiesCount <= MaxOldies) then
begin
FilesProcessed[OldiesCount] := TempString;
OldiesCount := succ(OldiesCount)
end;
otherwise
;
end; {Case statement }
end {if not ((TempString[1] = '•') & (length(TempString) = 1)) }
else
Mode := succ(Mode);
end; { if (TempString[1] <> ';') }
end; { while (not AtEOF(InfoFile)) }
Err := FSClose(InfoFile);
FileCount := pred(FileCount);
SendToCount := pred(SendToCount);
OldiesCount := pred(OldiesCount)
end;
{ ------------------------------------------------------ }
procedure CheckForFiles;
var
Counter, InfoFile, BackupFile, BulletCount: integer;
myPB: WDPBRec;
TempString, InfoName, BackupName: str255;
begin
GetGenericPath;
{get volume refnum}
WhereAt := Location;
MyPB.ioNamePtr := @WhereAt;
MyPB.ioCompletion := nil;
MyPB.ioVRefNum := 0;
MyPB.ioWDProcID := mySignature;
MyPB.ioWDDirID := 0;
Err := PBOpenWD(@MyPB, false);
{get WDRefnum}
WhereAt := Location;
MyPB.ioNamePtr := @WhereAt;
MyPB.ioCompletion := nil;
MyPB.ioNamePtr := nil;
{MyPB.ioVRefNum from above}
MyPB.ioWDProcID := mySignature;
Err := PBOpenWD(@MyPB, false);
ReadInfo;
for Counter := 1 to OldiesCount do
begin
TempString := FilesProcessed[Counter];
Verify(TempString, MyPB);
FilesProcessed[Counter] := TempString
end;
for Counter := 1 to FileCount do
LookFor(SendFiles[Counter], MyPB);
TempString := '';
InfoName := concat(Location, DataFileName);
BackupName := concat(InfoName, '.$');
BulletCount := 0;
Err := FSOpen(InfoName, vRefNum, InfoFile);
if Err = NoErr then
MakeTextFile(BackupName);
if Err = NoErr then
Err := FSOpen(BackupName, vRefNum, BackupFile);
if Err = NoErr then
repeat
Err := ReadALine(InfoFile, TempString);
if Err = NoErr then
Err := WrLn(BackupFile, TempString);
if (TempString[1] = '•') & (length(TempString) = 1) then
BulletCount := succ(BulletCount);
until (BulletCount = 2) | AtEOF(InfoFile) | (Err <> NoErr);
for Counter := 1 to OldiesCount do
if (Err = NoErr) & (FilesProcessed[Counter] <> '') then
Err := WrLn(BackupFile, FilesProcessed[Counter]);
Err := FSClose(BackupFile);
Err := FSClose(InfoFile);
if Err = NoErr then
Err := FSDelete(InfoName, vRefNum);
if Err = NoErr then
Err := Rename(BackupName, vRefNum, InfoName)
end;
{ ------------------------------------------------------ }
procedure SetUp;
begin
if GetString(500) <> nil then
NextLaunch := GetString(500)^^; { Get next launch string from resource }
if GetString(501) <> nil then
DataFileName := GetString(501)^^; {Get data file string from resource }
if GetString(502) <> nil then
Location := GetString(502)^^; {Get location string from resource }
if GetString(503) <> nil then
When := GetString(503)^^; {Get when string from resource }
if GetString(504) <> nil then
RegisterSTR := GetString(504)^^; {Get registration string }
Unreg := 'Not Registered';
VerifyRegistration;
ParamText(VERSION, '', '', '')
end;
{ ------------------------------------------------------ }
begin
MaxApplZone;
SetUp;
if Button then
Configure { If user is holding down the mouse button, reconfigure and end }
else
begin
if (Unreg[14] = 'd') & (Unreg[1] = 'N') & (Unreg[3] = 't') & (Unreg[7] = 'g') & (Unreg[12] = 'r') then
begin
RunDialog := GetNewDialog(501, nil, POINTER(-1));
SetPort(RunDialog);
DrawDialog(RunDialog);
HelloTabby;
if (StringToDay(When) = EveryDay) | (StringToDay(When) = WhatDay) then
CheckForFiles;
myCloseWD;
if (RunDialog <> nil) then
DisposDialog(RunDialog);
if NextLaunch <> '' then
LaunchNextAppl
end
end
end.